home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / tsystem.t < prev    next >
Text File  |  1988-05-02  |  4KB  |  126 lines
  1. (herald tsystem (env tsys))
  2.  
  3. ;;;; T Configuration file
  4.  
  5. ;;; ---------- Utilities for systems
  6.  
  7.  
  8. (define t-version-number 3001)
  9.  
  10. ;;; Fix file names are "<system-name>FIX<edit-number>.T" in the
  11. ;;; system directory.
  12.  
  13. (define (load-fix-file system env)
  14.   (let* ((name (format nil "~a~a~a"
  15.                        (string-downcase! (symbol->string (system-%name system)))
  16.                        (if (experimental?) "xfix" "fix")
  17.                        (link-edit system)))
  18.          (fname (make-filename nil (the-t-system-directory) name nil)))
  19.     (load-quietly-if-present fname env)))
  20.  
  21. ;;; Init file names are "<system-name>_init<edit-number>.T" in the
  22. ;;; system directory.
  23.  
  24. (define (load-init-file system env)
  25.   (let* ((name  (format nil "~ainit" (system-name system)))
  26.          (fname (make-filename nil (the-init-file-directory) name nil)))
  27.     (load-quietly-if-present fname env)))
  28.  
  29. ;;; System initialization stuff
  30.  
  31. ;;; Environment initialization.  Make a "Standard environment,"
  32. ;;; i.e. a fresh environment which has copies of all the "released"
  33. ;;; system bindings in it.
  34.  
  35. (define standard-env (make-empty-locale 'standard-env))
  36. (define standard-syntax-table (env-syntax-table standard-env))
  37.  
  38. (define (initialize-standard-env)
  39.   (export-tsys standard-env)
  40.   (*define standard-env 'standard-syntax-table (env-syntax-table standard-env))
  41.   ;++ flush at 3.1
  42.   (*define standard-env '*standard-syntax-table* (env-syntax-table standard-env))
  43.     ;++ gross hack to prevent crawl from blowing out.  what to do?
  44.     (*lset standard-env '*obj* nil)
  45.     (no-value))
  46.  
  47. ;;; Create a user environment inferior to the standard environment.
  48. ;;; The variable USER-ENV will be defined in the standard
  49. ;;; environment to be the new environment.
  50.  
  51. (define user-env     (make-inferior-locale standard-env 'user-env))
  52.  
  53. (define (initialize-t-system system)
  54.   (set *z?* '#f)
  55.   (set *top-level* standard-top-level)
  56.   (boot-adjust-initial-units)
  57.   (initialize-local-fs)
  58.   (initialize-local-system)
  59.   (initialize-standard-env)
  60.     ;++ temporary grossness
  61.   (*define tvm-env      '*standard-env* standard-env)
  62.   (*define standard-env '*standard-env* standard-env)
  63.   (*define tvm-env      '*scratch-env*  user-env)
  64.   (*define standard-env '*scratch-env*  user-env)
  65.   (load-fix-file system t-implementation-env)
  66.   (set (fancy-symbol-printing?) t)
  67.   (set (repl-env) user-env))
  68.  
  69. (define (re-initialize-t-system system)
  70.   (initialize-local-fs)
  71.   (initialize-local-system)
  72.   (load-fix-file system t-implementation-env)
  73.   (initialize-repl user-env))
  74.  
  75. (define t-system
  76.   (create-system 't (fx/ version-number 10) (fx-rem version-number 10) 6
  77.                  initialize-t-system
  78.                  re-initialize-t-system
  79.                  (lambda (system)
  80.                    (or (load-init-file system user-env)
  81.                        ;++ temp until 3.1
  82.                        (load-quietly-if-present
  83.                         (make-filename nil (the-init-file-directory) 'init nil)
  84.                         user-env)))
  85.                  "Copyright (C) 1988 Yale University"
  86.                  '()))
  87.  
  88. (define (version . arg)
  89.   (if (null? arg) t-system (car arg)))
  90.  
  91. ;;; Utility to load Orbit and Scheme and then suspend the system.
  92.  
  93. (define (load-and-suspend-system filespec . hack)
  94.   (if hack (gc))
  95.   (load '(build oload) t-implementation-env)
  96.   ((*value orbit-env 'load-orbit))
  97.   (let ((suspend-env (make-locale t-implementation-env 'suspend-env)))
  98.     (*define t-implementation-env 'suspend-env suspend-env)
  99.     (load '(link lp_table) suspend-env)
  100.     (load (machine-suspend-file (local-machine)) suspend-env)
  101.     (load '(link suspend) suspend-env)
  102.     (*define t-implementation-env 'system-suspend (*value suspend-env 'system-suspend)))
  103.     (load '(tscheme scheme) t-implementation-env)
  104.   (gc)                  
  105.   (if hack (set (process-global task/area-limit) (area-limit *old-space*)))
  106.   (system-suspend filespec nil))
  107.  
  108.  
  109. ;;; Standard top level, etc.
  110.  
  111. (lset *TOP-LEVEL-GREETING* "T Top level")
  112.  
  113. (define (STANDARD-TOP-LEVEL)
  114. ;++    (reset-stack-guard)
  115.   (set *z?* nil)
  116.   (t-breakpoint *top-level-greeting*))
  117.  
  118. (define (T-RESET)
  119.   (set *top-level* standard-top-level)
  120.   (**reset** nil))
  121.  
  122. ;;; End of basic system initialization sequence.
  123.  
  124. ;;; Control falls from here either into other embedded systems or
  125. ;;; into (*TOP-LEVEL*).
  126.